home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PAS_0793 / TPENV.PAS < prev    next >
Pascal/Delphi Source File  |  1993-08-01  |  16KB  |  614 lines

  1. {─ Fido Pascal Conference ────────────────────────────────────────────── PASCAL ─
  2. Msg  : 307 of 317                                                               
  3. From : Jon Jasiunas                        1:273/216.0          15 Jul 93  10:44 
  4. To   : All                                                                       
  5. Subj : Environment           1/7                                              
  6. ────────────────────────────────────────────────────────────────────────────────
  7. Since there's so much demand for environment access, here's Turbo
  8. Power's TPENV unit. I know it's a little on the large side, but I'm
  9. tired of seeing all these messages about how this can't be done, or how
  10. that can't be done when TPENV has allowed it since 1988.
  11.  
  12.    -----------------------------------------------------------------
  13. (Quoted from the accompanying documentation to verify it is in the
  14.  Public Domain.)
  15.  
  16. TPENV - Routines for manipulating the DOS environment
  17.    --------------------------------------------------
  18. Kim Kokkonen
  19. TurboPower Software
  20. 10/88
  21. Version 1.0
  22. Released to the Public Domain
  23.  
  24.    -------------------------- cut here -----------------------------}
  25. {$R-,S-,V-,I-,B-,F-}
  26.  
  27. {Disable the following define if you don't have Turbo Professional}
  28. {$DEFINE UseTpro}
  29.  
  30. {*********************************************************}
  31. {*                    TPENV.PAS 1.02                     *}
  32. {*                by TurboPower Software                 *}
  33. {*********************************************************}
  34.  
  35. {
  36.   Version 1.01 11/7/88
  37.     Find master environment in DOS 3.3 and 4.0
  38.   Version 1.02 11/14/88
  39.     Correctly find master environment when run
  40.       within AUTOEXEC.BAT
  41. }
  42.  
  43. unit TpEnv;
  44.   {-Manipulate the environment}
  45.  
  46. interface
  47.  
  48.   {$IFDEF UseTpro}
  49. uses
  50.   TpString,
  51.   TpDos;
  52.   {$ENDIF}
  53.  
  54. type
  55.   EnvArray = array[0..32767] of Char;
  56.   EnvArrayPtr = ^EnvArray;
  57.   EnvRec =
  58.     record
  59.       EnvSeg : Word;              {Segment of the environment}
  60.       EnvLen : Word;              {Usable length of the environment}
  61.       EnvPtr : Pointer;           {Nil except when allocated on heap}
  62.     end;
  63.  
  64. const
  65.   ShellUserProc : Pointer = nil;  {Put address of ExecDos user proc here if des
  66.  
  67. procedure MasterEnv(var Env : EnvRec);
  68.   {-Return master environment record}
  69.  
  70. procedure CurrentEnv(var Env : EnvRec);
  71.   {-Return current environment record}
  72.  
  73. procedure NewEnv(var Env : EnvRec; Size : Word);
  74.   {-Allocate a new environment on the heap}
  75.  
  76. procedure DisposeEnv(var Env : EnvRec);
  77.   {-Deallocate an environment previously allocated on heap}
  78.  
  79. procedure SetCurrentEnv(Env : EnvRec);
  80.   {-Specify a different environment for the current program}
  81.  
  82. procedure CopyEnv(Src, Dest : EnvRec);
  83.   {-Copy contents of Src environment to Dest environment}
  84.  
  85. function EnvFree(Env : EnvRec) : Word;
  86.   {-Return bytes free in environment}
  87.  
  88. function GetEnvStr(Env : EnvRec; Search : string) : string;
  89.   {-Return a string from the environment}
  90.  
  91. function SetEnvStr(Env : EnvRec; Search, Value : string) : Boolean;
  92.   {-Set environment string, returning true if successful}
  93.  
  94. procedure DumpEnv(Env : EnvRec);
  95.   {-Dump the environment to StdOut}
  96.  
  97. function ProgramStr : string;
  98.   {-Return the complete path to the current program, '' if DOS < 3.0}
  99.  
  100. function SetProgramStr(Env : EnvRec; Path : string) : Boolean;
  101.  
  102.  
  103.   {-Add a program name to the end of an environment if sufficient space}
  104.  
  105.   {$IFDEF UseTpro}
  106. function ShellWithPrompt(Prompt : string) : Integer;
  107.   {-Shell to DOS with a new prompt}
  108.   {$ENDIF}
  109.  
  110.   {===============================================================}
  111.  
  112. implementation
  113.  
  114. type
  115.   SO =
  116.     record
  117.       O : Word;
  118.       S : Word;
  119.     end;
  120.  
  121.   procedure ClearEnvRec(var Env : EnvRec);
  122.     {-Initialize an environment record}
  123.   begin
  124.     FillChar(Env, SizeOf(Env), 0);
  125.   end;
  126.  
  127.   procedure MasterEnv(var Env : EnvRec);
  128.     {-Return master environment record}
  129.   var
  130.     Owner : Word;
  131.     Mcb : Word;
  132.     Eseg : Word;
  133.     Done : Boolean;
  134.   begin
  135.     with Env do begin
  136.       ClearEnvRec(Env);
  137.  
  138.       {Interrupt $2E points into COMMAND.COM}
  139.       Owner := MemW[0:(2+4*$2E)];
  140.  
  141.       {Mcb points to memory control block for COMMAND}
  142.       Mcb := Owner-1;
  143.       if (Mem[Mcb:0] <> Byte('M')) or (MemW[Mcb:1] <> Owner) then
  144.         Exit;
  145.  
  146.       {Read segment of environment from PSP of COMMAND}
  147.       Eseg := MemW[Owner:$2C];
  148.  
  149.       {Earlier versions of DOS don't store environment segment there}
  150.       if Eseg = 0 then begin
  151.         {Master environment is next block past COMMAND}
  152.         Mcb := Owner+MemW[Mcb:3];
  153.         if (Mem[Mcb:0] <> Byte('M')) or (MemW[Mcb:1] <> Owner) then
  154.           {Not the right memory control block}
  155.           Exit;
  156.         Eseg := Mcb+1;
  157.       end else
  158.         Mcb := Eseg-1;
  159.  
  160.       {Return segment and length of environment}
  161.       EnvSeg := Eseg;
  162.       EnvLen := MemW[Mcb:3] shl 4;
  163.     end;
  164.   end;
  165.  
  166.   procedure CurrentEnv(var Env : EnvRec);
  167.     {-Return current environment record}
  168.   var
  169.     ESeg : Word;
  170.     Mcb : Word;
  171.   begin
  172.     with Env do begin
  173.       ClearEnvRec(Env);
  174.       ESeg := MemW[PrefixSeg:$2C];
  175.       Mcb := ESeg-1;
  176.       if (Mem[Mcb:0] <> Byte('M')) or (MemW[Mcb:1] <> PrefixSeg) then
  177.         Exit;
  178.       EnvSeg := ESeg;
  179.       EnvLen := MemW[Mcb:3] shl 4;
  180.     end;
  181.   end;
  182.  
  183.   procedure NewEnv(var Env : EnvRec; Size : Word);
  184.     {-Allocate a new environment (on the heap)}
  185.   var
  186.     Mcb : Word;
  187.   begin
  188.     with Env do
  189.       if MaxAvail < Size+31 then
  190.         {Insufficient space}
  191.         ClearEnvRec(Env)
  192.       else begin
  193.         {31 extra bytes for paragraph alignment, fake MCB}
  194.         GetMem(EnvPtr, Size+31);
  195.         EnvSeg := SO(EnvPtr).S+1;
  196.         if SO(EnvPtr).O <> 0 then
  197.           Inc(EnvSeg);
  198.         EnvLen := Size;
  199.         {Fill it with nulls}
  200.         FillChar(EnvPtr^, Size+31, 0);
  201.         {Make a fake MCB below it}
  202.         Mcb := EnvSeg-1;
  203.         Mem[Mcb:0] := Byte('M');
  204.         MemW[Mcb:1] := PrefixSeg;
  205.         MemW[Mcb:3] := (Size+15) shr 4;
  206.       end;
  207.   end;
  208.  
  209.   procedure DisposeEnv(var Env : EnvRec);
  210.     {-Deallocate an environment previously allocated on heap}
  211.   begin
  212.     with Env do
  213.       if EnvPtr <> nil then begin
  214.         FreeMem(EnvPtr, EnvLen+31);
  215.         ClearEnvRec(Env);
  216.       end;
  217.   end;
  218.  
  219.   procedure SetCurrentEnv(Env : EnvRec);
  220.     {-Specify a different environment for the current program}
  221.   begin
  222.     with Env do
  223.       if EnvSeg <> 0 then
  224.         MemW[PrefixSeg:$2C] := EnvSeg;
  225.   end;
  226.  
  227.   procedure CopyEnv(Src, Dest : EnvRec);
  228.     {-Copy contents of Src environment to Dest environment}
  229.   var
  230.     Size : Word;
  231.     SPtr : EnvArrayPtr;
  232.     DPtr : EnvArrayPtr;
  233.   begin
  234.     if (Src.EnvSeg = 0) or (Dest.EnvSeg = 0) then
  235.       Exit;
  236.  
  237.     if Src.EnvLen <= Dest.EnvLen then
  238.       {Space for the whole thing}
  239.       Size := Src.EnvLen
  240.     else
  241.       {Take what fits}
  242.       Size := Dest.EnvLen-1;
  243.  
  244.     SPtr := Ptr(Src.EnvSeg, 0);
  245.     DPtr := Ptr(Dest.EnvSeg, 0);
  246.     Move(SPtr^, DPtr^, Size);
  247.     FillChar(DPtr^[Size], Dest.EnvLen-Size, 0);
  248.   end;
  249.  
  250.   procedure SkipAsciiZ(EPtr : EnvArrayPtr; var EOfs : Word);
  251.     {-Skip to end of current AsciiZ string}
  252.   begin
  253.     while EPtr^[EOfs] <> #0 do
  254.       Inc(EOfs);
  255.   end;
  256.  
  257.   function EnvNext(EPtr : EnvArrayPtr) : Word;
  258.     {-Return the next available location in environment at EPtr^}
  259.   var
  260.     EOfs : Word;
  261.   begin
  262.     EOfs := 0;
  263.     if EPtr <> nil then begin
  264.       while EPtr^[EOfs] <> #0 do begin
  265.         SkipAsciiZ(EPtr, EOfs);
  266.         Inc(EOfs);
  267.       end;
  268.     end;
  269.     EnvNext := EOfs;
  270.   end;
  271.  
  272.   function EnvFree(Env : EnvRec) : Word;
  273.     {-Return bytes free in environment}
  274.   begin
  275.     with Env do
  276.       if EnvSeg <> 0 then
  277.         EnvFree := EnvLen-EnvNext(Ptr(EnvSeg, 0))-1
  278.       else
  279.         EnvFree := 0;
  280.   end;
  281.  
  282.   {$IFNDEF UseTpro}
  283.   function StUpcase(S : string) : string;
  284.     {-Uppercase a string}
  285.   var
  286.     SLen : byte absolute S;
  287.     I : Integer;
  288.   begin
  289.     for I := 1 to SLen do
  290.       S[I] := UpCase(S[I]);
  291.     StUpcase := S;
  292.   end;
  293.   {$ENDIF}
  294.  
  295.   function SearchEnv(EPtr : EnvArrayPtr;
  296.                      var Search : string) : Word;
  297.     {-Return the position of Search in environment, or $FFFF if not found.
  298.       Prior to calling SearchEnv, assure that
  299.         EPtr is not nil,
  300.         Search is not empty
  301.     }
  302.   var
  303.     SLen : Byte absolute Search;
  304.     EOfs : Word;
  305.     MOfs : Word;
  306.     SOfs : Word;
  307.     Match : Boolean;
  308.   begin
  309.     {Force upper case search}
  310.     Search := StUpcase(Search);
  311.  
  312.     {Assure search string ends in =}
  313.     if Search[SLen] <> '=' then begin
  314.       Inc(SLen);
  315.       Search[SLen] := '=';
  316.     end;
  317.  
  318.     EOfs := 0;
  319.     while EPtr^[EOfs] <> #0 do begin
  320.       {At the start of a new environment element}
  321.       SOfs := 1;
  322.       MOfs := EOfs;
  323.       repeat
  324.         Match := (EPtr^[EOfs] = Search[SOfs]);
  325.         if Match then begin
  326.           Inc(EOfs);
  327.           Inc(SOfs);
  328.         end;
  329.       until not Match or (SOfs > SLen);
  330.  
  331.       if Match then begin
  332.         {Found a match, return index of start of match}
  333.         SearchEnv := MOfs;
  334.         Exit;
  335.       end;
  336.  
  337.       {Skip to end of this environment string}
  338.       SkipAsciiZ(EPtr, EOfs);
  339.  
  340.       {Skip to start of next environment string}
  341.       Inc(EOfs);
  342.     end;
  343.  
  344.     {No match}
  345.     SearchEnv := $FFFF;
  346.   end;
  347.  
  348.   procedure GetAsciiZ(EPtr : EnvArrayPtr; var EOfs : Word; var EStr : string);
  349.     {-Collect AsciiZ string starting at EPtr^[EOfs]}
  350.   var
  351.     ELen : Byte absolute EStr;
  352.   begin
  353.     ELen := 0;
  354.     while (EPtr^[EOfs] <> #0) and (ELen < 255) do begin
  355.       Inc(ELen);
  356.       EStr[ELen] := EPtr^[EOfs];
  357.       Inc(EOfs);
  358.     end;
  359.   end;
  360.  
  361.   function GetEnvStr(Env : EnvRec; Search : string) : string;
  362.     {-Return a string from the environment}
  363.   var
  364.     SLen : Byte absolute Search;
  365.     EPtr : EnvArrayPtr;
  366.     EOfs : Word;
  367.     EStr : string;
  368.     ELen : Byte absolute EStr;
  369.   begin
  370.     with Env do begin
  371.       ELen := 0;
  372.       if (EnvSeg <> 0) and (SLen <> 0) then begin
  373.         {Find the search string}
  374.         EPtr := Ptr(EnvSeg, 0);
  375.         EOfs := SearchEnv(EPtr, Search);
  376.         if EOfs <> $FFFF then begin
  377.           {Skip over the search string}
  378.           Inc(EOfs, SLen);
  379.           {Build the result string}
  380.           GetAsciiZ(EPtr, EOfs, EStr);
  381.         end;
  382.       end;
  383.       GetEnvStr := EStr;
  384.     end;
  385.   end;
  386.  
  387.   function SetEnvStr(Env : EnvRec; Search, Value : string) : Boolean;
  388.     {-Set environment string, returning true if successful}
  389.   var
  390.     SLen : Byte absolute Search;
  391.     VLen : Byte absolute Value;
  392.     EPtr : EnvArrayPtr;
  393.     ENext : Word;
  394.     EOfs : Word;
  395.     MOfs : Word;
  396.     OldLen : Word;
  397.     NewLen : Word;
  398.     NulLen : Word;
  399.   begin
  400.     with Env do begin
  401.       SetEnvStr := False;
  402.       if (EnvSeg = 0) or (SLen = 0) then
  403.         Exit;
  404.       EPtr := Ptr(EnvSeg, 0);
  405.  
  406.       {Find the search string}
  407.       EOfs := SearchEnv(EPtr, Search);
  408.  
  409.       {Get the index of the next available environment location}
  410.       ENext := EnvNext(EPtr);
  411.  
  412.       {Get total length of new environment string}
  413.       NewLen := SLen+VLen;
  414.  
  415.       if EOfs <> $FFFF then begin
  416.         {Search string exists}
  417.         MOfs := EOfs+SLen;
  418.         {Scan to end of string}
  419.         SkipAsciiZ(EPtr, MOfs);
  420.         OldLen := MOfs-EOfs;
  421.         {No extra nulls to add}
  422.         NulLen := 0;
  423.       end else begin
  424.         OldLen := 0;
  425.         {One extra null to add}
  426.         NulLen := 1;
  427.       end;
  428.  
  429.       if VLen <> 0 then
  430.         {Not a pure deletion}
  431.         if ENext+NewLen+NulLen >= EnvLen+OldLen then
  432.           {New string won't fit}
  433.           Exit;
  434.  
  435.       if OldLen <> 0 then begin
  436.         {Overwrite previous environment string}
  437.         Move(EPtr^[MOfs+1], EPtr^[EOfs], ENext-MOfs-1);
  438.         {More space free now}
  439.         Dec(ENext, OldLen+1);
  440.       end;
  441.  
  442.       {Append new string}
  443.       if VLen <> 0 then begin
  444.         Move(Search[1], EPtr^[ENext], SLen);
  445.         Inc(ENext, SLen);
  446.         Move(Value[1], EPtr^[ENext], VLen);
  447.         Inc(ENext, VLen);
  448.       end;
  449.  
  450.       {Clear out the rest of the environment}
  451.       FillChar(EPtr^[ENext], EnvLen-ENext, 0);
  452.  
  453.       SetEnvStr := True;
  454.     end;
  455.   end;
  456.  
  457.   procedure DumpEnv(Env : EnvRec);
  458.     {-Dump the environment to StdOut}
  459.   var
  460.     EOfs : Word;
  461.     EPtr : EnvArrayPtr;
  462.   begin
  463.     with Env do begin
  464.       if EnvSeg = 0 then
  465.         Exit;
  466.       EPtr := Ptr(EnvSeg, 0);
  467.       EOfs := 0;
  468.       WriteLn;
  469.       while EPtr^[EOfs] <> #0 do begin
  470.         while EPtr^[EOfs] <> #0 do begin
  471.           Write(EPtr^[EOfs]);
  472.           Inc(EOfs);
  473.         end;
  474.         WriteLn;
  475.         Inc(EOfs);
  476.       end;
  477.       WriteLn('Bytes free: ', EnvFree(Env));
  478.     end;
  479.   end;
  480.  
  481.   function DosVersion : Word;
  482.     {-Return the DOS version, major part in AX}
  483.   inline(
  484.          $B4/$30/                 {mov ah,$30}
  485.          $CD/$21/                 {int $21}
  486.          $86/$C4);                {xchg ah,al}
  487.  
  488.   function ProgramStr : string;
  489.     {-Return the name of the current program, '' if DOS < 3.0}
  490.   var
  491.     EOfs : Word;
  492.     Env : EnvRec;
  493.     EPtr : EnvArrayPtr;
  494.     PStr : string;
  495.   begin
  496.     ProgramStr := '';
  497.     if DosVersion < $0300 then
  498.       Exit;
  499.     CurrentEnv(Env);
  500.     if Env.EnvSeg = 0 then
  501.       Exit;
  502.     {Find the end of the current environment}
  503.     EPtr := Ptr(Env.EnvSeg, 0);
  504.     EOfs := EnvNext(EPtr);
  505.     {Skip to start of path name}
  506.     Inc(EOfs, 3);
  507.     {Collect the path name}
  508.     GetAsciiZ(EPtr, EOfs, PStr);
  509.     ProgramStr := PStr;
  510.   end;
  511.  
  512.   function SetProgramStr(Env : EnvRec; Path : string) : Boolean;
  513.     {-Add a program name to the end of an environment if sufficient space}
  514.   var
  515.     PLen : Byte absolute Path;
  516.     EOfs : Word;
  517.     Numb : Word;
  518.     EPtr : EnvArrayPtr;
  519.   begin
  520.     SetProgramStr := False;
  521.     with Env do begin
  522.       if EnvSeg = 0 then
  523.         Exit;
  524.       {Find the end of the current environment}
  525.       EPtr := Ptr(EnvSeg, 0);
  526.       EOfs := EnvNext(EPtr);
  527.       {Assure space for path}
  528.       if EnvLen < PLen+EOfs+4 then
  529.         Exit;
  530.       {Put in the count field}
  531.       Inc(EOfs);
  532.       Numb := 1;
  533.       Move(Numb, EPtr^[EOfs], 2);
  534.       {Skip to start of path name}
  535.       Inc(EOfs, 2);
  536.       {Move the path into place}
  537.       Path := StUpcase(Path);
  538.       Move(Path[1], EPtr^[EOfs], PLen);
  539.       {Null terminate}
  540.       Inc(EOfs, PLen);
  541.       EPtr^[EOfs] := #0;
  542.       SetProgramStr := True;
  543.     end;
  544.   end;
  545.  
  546.   {$IFDEF UseTpro}
  547.   function ShellWithPrompt(Prompt : string) : Integer;
  548.     {-Shell to DOS with a new prompt}
  549.   const
  550.     PromptStr : string[7] = 'PROMPT=';
  551.   var
  552.     PLen : Byte absolute Prompt;
  553.     NSize : Word;
  554.     Status : Integer;
  555.     CE : EnvRec;
  556.     NE : EnvRec;
  557.     OldP : string;
  558.     OldPLen : Byte absolute OldP;
  559.   begin
  560.     {Point to current environment}
  561.     CurrentEnv(CE);
  562.     if CE.EnvSeg = 0 then begin
  563.       {Error getting environment}
  564.       ShellWithPrompt := -5;
  565.       Exit;
  566.     end;
  567.  
  568.     {Compute size of new environment}
  569.     OldP := GetEnvStr(CE, PromptStr);
  570.     NSize := CE.EnvLen;
  571.     if OldPLen < PLen then
  572.       Inc(NSize, PLen-OldPLen);
  573.     {Allocate and initialize a new environment}
  574.     NewEnv(NE, NSize);
  575.     if NE.EnvSeg = 0 then begin
  576.       {Insufficient memory for new environment}
  577.       ShellWithPrompt := -6;
  578.       Exit;
  579.     end;
  580.     CopyEnv(CE, NE);
  581.  
  582.     {Get the program name from the current environment}
  583.     OldP := ProgramStr;
  584.  
  585.     {Set the new prompt string}
  586.     if not SetEnvStr(NE, PromptStr, Prompt) then begin
  587.       {Program error, should have enough space}
  588.       ShellWithPrompt := -7;
  589.       Exit;
  590.     end;
  591.  
  592.     {Transfer program name to new environment if possible}
  593.     if not SetProgramStr(NE, OldP) then
  594.       ;
  595.  
  596.     {Point to new environment}
  597.     SetCurrentEnv(NE);
  598.  
  599.     {Shell to DOS with new prompt in place}
  600.     Status := ExecDos('', True, ShellUserProc);
  601.  
  602.     {Restore previous environment}
  603.     SetCurrentEnv(CE);
  604.  
  605.     {Release the heap space}
  606.     if Status >= 0 then
  607.       DisposeEnv(NE);
  608.  
  609.     {Return exec status}
  610.     ShellWithPrompt := Status;
  611.   end;
  612.   {$ENDIF}
  613.  
  614. end.